home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / string.d < prev    next >
Lisp/Scheme  |  1987-06-03  |  13KB  |  601 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     string.d
  9.  
  10.     string routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. object Kstart1;
  16. object Kend1;
  17. object Kstart2;
  18. object Kend2;
  19. object Kinitial_element;
  20. object Kstart;
  21. object Kend;
  22.  
  23. object
  24. alloc_simple_string(l)
  25. int l;
  26. {
  27.     object x;
  28.  
  29.     x = alloc_object(t_string);
  30.     x->st.st_hasfillp = FALSE;
  31.     x->st.st_adjustable = FALSE;
  32.     x->st.st_displaced = Cnil;
  33.     x->st.st_dim = x->st.st_fillp = l;
  34.     x->st.st_self = NULL;
  35.     return(x);
  36. }
  37.  
  38. /*
  39.     Make_simple_string(s) makes a simple string from C string s.
  40. */
  41. object
  42. make_simple_string(s)
  43. char *s;
  44. {
  45.     int l, i;
  46.     char *p;
  47.     object x;
  48.     vs_mark;
  49.  
  50.     for (l = 0;  s[l] != '\0';  l++)
  51.         ;
  52.     x = alloc_simple_string(l);
  53.     vs_push(x);
  54.     p = alloc_relblock(l);
  55.     for (i = 0;  i < l;  i++)
  56.         p[i] = s[i];
  57.     x->st.st_self = p;
  58.     vs_reset;
  59.     return(x);
  60. }
  61.  
  62. /*
  63.     This correponds to string= (just the string equality).
  64. */
  65. bool
  66. string_eq(x, y)
  67. object x, y;
  68. {
  69.     int i, j;
  70.  
  71. /*
  72.     if (type_of(x) != t_string || type_of(y) != t_string)
  73.         error("string expected");
  74. */
  75.     i = x->st.st_fillp;
  76.     j = y->st.st_fillp;
  77.     if (i != j)
  78.         return(FALSE);
  79.     for (i = 0;  i < j;  i++)
  80.         if (x->st.st_self[i] != y->st.st_self[i])
  81.             return(FALSE);
  82.     return(TRUE);
  83. }
  84.  
  85. /*
  86.     This corresponds to string-equal
  87.     (string equality ignoring the case).
  88. */
  89. bool
  90. string_equal(x, y)
  91. object x, y;
  92. {
  93.     int i, j;
  94.     char *p, *q;
  95.  
  96. /*
  97.     if (type_of(x) != t_string || type_of(y) != t_string)
  98.         error("string expected");
  99. */
  100.     i = x->st.st_fillp;
  101.     j = y->st.st_fillp;
  102.     if (i != j)
  103.         return(FALSE);
  104.     p = x->st.st_self;
  105.     q = y->st.st_self;
  106.     for (i = 0;  i < j;  i++)
  107.         if ((isLower(p[i]) ? p[i] - ('a' - 'A') : p[i])
  108.          != (isLower(q[i]) ? q[i] - ('a' - 'A') : q[i]))
  109.             return(FALSE);
  110.     return(TRUE);
  111. }
  112.  
  113. /*
  114.     Copy_simple_string(x) copies string x to a simple string.
  115. */
  116. object
  117. copy_simple_string(x)
  118. object x;
  119. {
  120.     object y;
  121.     int i;
  122.     vs_mark;
  123.  
  124.     vs_push(x);
  125. /*
  126.     if (type_of(x) != t_string)
  127.         error("string expected");
  128. */
  129.     y = alloc_object(t_string);
  130.     y->st.st_dim = y->st.st_fillp = x->st.st_fillp;
  131.     y->st.st_hasfillp = FALSE;
  132.     y->st.st_adjustable = FALSE;
  133.     y->st.st_displaced = Cnil;
  134.     y->st.st_self = NULL;
  135.     vs_push(y);
  136.     y->st.st_self = alloc_relblock(x->st.st_fillp);
  137.     for (i = 0;  i < x->st.st_fillp;  i++)
  138.         y->st.st_self[i] = x->st.st_self[i];
  139.     vs_reset;
  140.     return(y);
  141. }
  142.  
  143. object
  144. coerce_to_string(x)
  145. object x;
  146. {
  147.     object y;
  148.     int i;
  149.     vs_mark;
  150.  
  151.     switch (type_of(x)) {
  152.     case t_symbol:
  153.         y = alloc_simple_string(x->s.s_fillp);
  154.         vs_push(y);
  155.         if (x->s.s_self < heap_end)
  156.             y->st.st_self = x->s.s_self;
  157.         else {
  158.             y->st.st_self = alloc_relblock(x->s.s_fillp);
  159.             for (i = 0;  i < x->s.s_fillp;  i++)
  160.                 y->st.st_self[i] = x->s.s_self[i];
  161.         }
  162.         vs_reset;
  163.         return(y);
  164.  
  165.     case t_fixnum:
  166.         x = coerce_to_character(x);
  167.         vs_push(x);
  168.  
  169.     case t_character:
  170.         y = alloc_simple_string(1);
  171.         vs_push(y);
  172.         y->st.st_self = alloc_relblock(1);
  173.         y->st.st_self[0] = char_code(x);
  174.         vs_reset;
  175.         return(y);
  176.  
  177.     case t_string:
  178.         return(x);
  179.     }
  180.     FEerror("~S cannot be coerced to a string.", 1, x);
  181. }
  182.  
  183. @(defun char (s i)
  184.     int j;
  185. @
  186.     check_type_string(&s);
  187.     if (type_of(i) != t_fixnum)
  188.         illegal_index(s, i);
  189.     if ((j = fix(i)) < 0 || j >= s->st.st_fillp)
  190.         illegal_index(s, i);
  191.     @(return `code_char(s->ust.ust_self[j])`)
  192. @)
  193.  
  194. siLchar_set()
  195. {
  196.     int j;
  197.  
  198.     check_arg(3);
  199.     check_type_string(&vs_base[0]);
  200.     if (type_of(vs_base[1]) != t_fixnum)
  201.         illegal_index(vs_base[0], vs_base[1]);
  202.     if ((j = fix(vs_base[1])) < 0 || j >= vs_base[0]->st.st_fillp)
  203.         illegal_index(vs_base[0], vs_base[1]);
  204.     check_type_character(&vs_base[2]);
  205.     vs_base[0]->st.st_self[j] = char_code(vs_base[2]);
  206.     vs_base += 2;
  207. }
  208.  
  209. get_string_start_end(string, start, end, ps, pe)
  210. object string, start, end;
  211. int *ps, *pe;
  212. {
  213.     if (start == Cnil)
  214.         *ps = 0;
  215.     else if (type_of(start) != t_fixnum)
  216.         goto E;
  217.     else {
  218.         *ps = fix(start);
  219.         if (*ps < 0)
  220.             goto E;
  221.     }
  222.     if (end == Cnil) {
  223.         *pe = string->st.st_fillp;
  224.         if (*pe < *ps)
  225.             goto E;
  226.     } else if (type_of(end) != t_fixnum)
  227.         goto E;
  228.     else {
  229.         *pe = fix(end);
  230.         if (*pe < *ps || *pe > string->st.st_fillp)
  231.             goto E;
  232.     }
  233.     return;
  234.  
  235. E:
  236.     FEerror("~S and ~S are illegal as :START and :END~%\
  237. for the string ~S.", 3, start, end, string);
  238. }
  239.  
  240. @(defun string_eq (string1 string2
  241.            &key start1 end1 start2 end2)
  242.     int s1, e1, s2, e2;
  243. @
  244.     string1 = coerce_to_string(string1);
  245.     string2 = coerce_to_string(string2);
  246.     get_string_start_end(string1, start1, end1, &s1, &e1);
  247.     get_string_start_end(string2, start2, end2, &s2, &e2);
  248.     if (e1 - s1 != e2 - s2)
  249.         @(return Cnil)
  250.     while (s1 < e1)
  251.         if (string1->st.st_self[s1++] !=
  252.             string2->st.st_self[s2++])
  253.             @(return Cnil)
  254.     @(return Ct)
  255. @)
  256.  
  257. @(defun string_equal (string1 string2
  258.               &key start1 end1 start2 end2)
  259.     int s1, e1, s2, e2;
  260.     int i1, i2;
  261. @
  262.     string1 = coerce_to_string(string1);
  263.     string2 = coerce_to_string(string2);
  264.     get_string_start_end(string1, start1, end1, &s1, &e1);
  265.     get_string_start_end(string2, start2, end2, &s2, &e2);
  266.     if (e1 - s1 != e2 - s2)
  267.         @(return Cnil)
  268.     while (s1 < e1) {
  269.         i1 = string1->st.st_self[s1++];
  270.         i2 = string2->st.st_self[s2++];
  271.         if (isLower(i1))
  272.             i1 -= 'a' - 'A';
  273.         if (isLower(i2))
  274.             i2 -= 'a' - 'A';
  275.         if (i1 != i2)
  276.             @(return Cnil)
  277.     }
  278.     @(return Ct)
  279. @)
  280.  
  281.  
  282. static int sign, boundary;
  283.  
  284. @(defun string_cmp (string1 string2
  285.             &key start1 end1 start2 end2)
  286.     int s1, e1, s2, e2;
  287.     int i1, i2;
  288.     int s;
  289. @
  290.     string1 = coerce_to_string(string1);
  291.     string2 = coerce_to_string(string2);
  292.     get_string_start_end(string1, start1, end1, &s1, &e1);
  293.     get_string_start_end(string2, start2, end2, &s2, &e2);
  294.     while (s1 < e1) {
  295.         if (s2 == e2)
  296.             @(return `sign>0 ? Cnil : make_fixnum(s1)`)
  297.         i1 = string1->ust.ust_self[s1];
  298.         i2 = string2->ust.ust_self[s2];
  299.         if (sign == 0) {
  300.             if (i1 != i2)
  301.                 @(return `make_fixnum(s1)`)
  302.         } else {
  303.             s = sign*(i2-i1);
  304.             if (s > 0)
  305.                 @(return `make_fixnum(s1)`)
  306.             if (s < 0)
  307.                 @(return Cnil)
  308.         }
  309.         s1++;
  310.         s2++;
  311.     }
  312.     if (s2 == e2)
  313.         @(return `boundary==0 ? make_fixnum(s1) : Cnil`)
  314.     @(return `sign>=0 ? make_fixnum(s1) : Cnil`)
  315. @)
  316.  
  317. Lstring_l()  { sign =  1;  boundary = 1;  Lstring_cmp(); }
  318. Lstring_g()  { sign = -1;  boundary = 1;  Lstring_cmp(); }
  319. Lstring_le() { sign =  1;  boundary = 0;  Lstring_cmp(); }
  320. Lstring_ge() { sign = -1;  boundary = 0;  Lstring_cmp(); }
  321. Lstring_neq() { sign = 0;  boundary = 1;  Lstring_cmp(); }
  322.  
  323. @(defun string_compare (string1 string2
  324.             &key start1 end1 start2 end2)
  325.     int s1, e1, s2, e2;
  326.     int i1, i2;
  327.     int s;
  328. @
  329.     string1 = coerce_to_string(string1);
  330.     string2 = coerce_to_string(string2);
  331.     get_string_start_end(string1, start1, end1, &s1, &e1);
  332.     get_string_start_end(string2, start2, end2, &s2, &e2);
  333.     while (s1 < e1) {
  334.         if (s2 == e2)
  335.             @(return `sign>0 ? Cnil : make_fixnum(s1)`)
  336.         i1 = string1->ust.ust_self[s1];
  337.         if (isLower(i1))
  338.             i1 -= 'a' - 'A';
  339.         i2 = string2->ust.ust_self[s2];
  340.         if (isLower(i2))
  341.             i2 -= 'a' - 'A';
  342.         if (sign == 0) {
  343.             if (i1 != i2)
  344.                 @(return `make_fixnum(s1)`)
  345.         } else {
  346.             s = sign*(i2-i1);
  347.             if (s > 0)
  348.                 @(return `make_fixnum(s1)`)
  349.             if (s < 0)
  350.                 @(return Cnil)
  351.         }
  352.         s1++;
  353.         s2++;
  354.     }
  355.     if (s2 == e2)
  356.         @(return `boundary==0 ? make_fixnum(s1) : Cnil`)
  357.     @(return `sign>=0 ? make_fixnum(s1) : Cnil`)
  358. @)
  359.  
  360. Lstring_lessp()         { sign =  1; boundary = 1;  Lstring_compare(); }
  361. Lstring_greaterp()      { sign = -1; boundary = 1;  Lstring_compare(); }
  362. Lstring_not_greaterp()  { sign =  1; boundary = 0;  Lstring_compare(); }
  363. Lstring_not_lessp()     { sign = -1; boundary = 0;  Lstring_compare(); }
  364. Lstring_not_equal()    { sign =  0; boundary = 1;  Lstring_compare(); }
  365.  
  366.  
  367. @(defun make_string (size
  368.              &key (initial_element `code_char(' ')`)
  369.              &aux x)
  370.     int i;
  371. @
  372.     while (type_of(size) != t_fixnum || fix(size) < 0)
  373.         size
  374.         = wrong_type_argument(TSnon_negative_integer, size);
  375.         /*  bignum not allowed, this is PRACTICAL!!  */
  376.     while (type_of(initial_element) != t_character ||
  377.            char_bits(initial_element) != 0 ||
  378.            char_font(initial_element) != 0)
  379.         initial_element
  380.         = wrong_type_argument(Sstring_char, initial_element);
  381.     x = alloc_simple_string(fix(size));
  382.     x->st.st_self = alloc_relblock(fix(size));
  383.     for (i = 0;  i < fix(size);  i++)
  384.         x->st.st_self[i] = char_code(initial_element);
  385.     @(return x)
  386. @)
  387.  
  388. bool
  389. member_char(c, char_bag)
  390. int c;
  391. object char_bag;
  392. {
  393.     int i, f;
  394.  
  395.     switch (type_of(char_bag)) {
  396.     case t_symbol:
  397.     case t_cons:
  398.         while (!endp(char_bag)) {
  399.             if (type_of(char_bag->c.c_car) != t_character)
  400.                 continue;
  401.             if (c == char_code(char_bag->c.c_car))
  402.                 return(TRUE);
  403.             char_bag = char_bag->c.c_cdr;
  404.         }
  405.         return(FALSE);
  406.  
  407.     case t_vector:
  408.         for (i = 0, f = char_bag->v.v_fillp;  i < f;  i++) {
  409.             if (type_of(char_bag->v.v_self[i]) != t_character)
  410.                 continue;
  411.             if (c == char_code(char_bag->v.v_self[i]))
  412.                 return(TRUE);
  413.         }
  414.         return(FALSE);
  415.  
  416.     case t_string:
  417.         for (i = 0, f = char_bag->st.st_fillp;  i < f;  i++) {
  418.             if (c == char_bag->st.st_self[i])
  419.                 return(TRUE);
  420.         }
  421.         return(FALSE);
  422.  
  423.     case t_bitvector:
  424.         return(FALSE);
  425.  
  426.     default:
  427.         FEerror("~S is not a sequence.", 1, char_bag);
  428.     }
  429. }
  430.  
  431. static bool left_trim;
  432. static bool right_trim;
  433.  
  434. Lstring_trim() { left_trim = right_trim = TRUE; Lstring_trim0(); }
  435. Lstring_left_trim() { left_trim = TRUE; right_trim = FALSE; Lstring_trim0(); }
  436. Lstring_right_trim() { left_trim = FALSE; right_trim = TRUE; Lstring_trim0();}
  437.  
  438. @(defun string_trim0 (char_bag strng &aux res)
  439.     int i, j, k;
  440. @
  441.     strng = coerce_to_string(strng);
  442.     i = 0;
  443.     j = strng->st.st_fillp - 1;
  444.     if (left_trim)
  445.         for (;  i <= j;  i++)
  446.             if (!member_char(strng->st.st_self[i], char_bag))
  447.                 break;
  448.     if (right_trim)
  449.         for (;  j >= i;  --j)
  450.             if (!member_char(strng->st.st_self[j], char_bag))
  451.                 break;
  452.     k = j - i + 1;
  453.     res = alloc_simple_string(k);
  454.     res->st.st_self = alloc_relblock(k);
  455.     for (j = 0;  j < k;  j++)
  456.         res->st.st_self[j] = strng->st.st_self[i + j];
  457.     @(return res)
  458. @)
  459.  
  460. static char_upcase(c, bp)
  461. int c, *bp;
  462. {
  463.     if (isLower(c))
  464.         return(c - ('a' - 'A'));
  465.     else
  466.         return(c);
  467. }
  468.  
  469. static char_downcase(c, bp)
  470. int c, *bp;
  471. {
  472.     if (isUpper(c))
  473.         return(c + ('a' - 'A'));
  474.     else
  475.         return(c);
  476. }
  477.  
  478. static char_capitalize(c, bp)
  479. int c, *bp;
  480. {
  481.     if (isLower(c)) {
  482.         if (*bp)
  483.             c -= 'a' - 'A';
  484.         *bp = FALSE;
  485.     } else if (isUpper(c)) {
  486.         if (!*bp)
  487.             c += 'a' - 'A';
  488.         *bp = FALSE;
  489.     } else if (!isDigit(c))
  490.         *bp = TRUE;
  491.     return(c);
  492. }
  493.  
  494. static (*casefun)();
  495.  
  496.  
  497. @(defun string_case (strng &key start end &aux conv)
  498.     int s, e, i;
  499.     bool b;
  500. @
  501.     strng = coerce_to_string(strng);
  502.     get_string_start_end(strng, start, end, &s, &e);
  503.     conv = copy_simple_string(strng);
  504.     b = TRUE;
  505.     for (i = s;  i < e;  i++)
  506.         conv->st.st_self[i] =
  507.         (*casefun)(conv->st.st_self[i], &b);
  508.     @(return conv)
  509. @)
  510.  
  511. Lstring_upcase()     { casefun =     char_upcase;  Lstring_case(); }
  512. Lstring_downcase()   { casefun =   char_downcase;  Lstring_case(); }
  513. Lstring_capitalize() { casefun = char_capitalize;  Lstring_case(); }
  514.  
  515.  
  516. @(defun nstring_case (strng &key start end)
  517.     int s, e, i;
  518.     bool b;
  519. @
  520.     check_type_string(&strng);
  521.     get_string_start_end(strng, start, end, &s, &e);
  522.     b = TRUE;
  523.     for (i = s;  i < e;  i++)
  524.         strng->st.st_self[i] =
  525.         (*casefun)(strng->st.st_self[i], &b);
  526.     @(return strng)
  527. @)
  528.  
  529. Lnstring_upcase()     { casefun =     char_upcase;  Lnstring_case(); }
  530. Lnstring_downcase()   { casefun =   char_downcase;  Lnstring_case(); }
  531. Lnstring_capitalize() { casefun = char_capitalize;  Lnstring_case(); }
  532.  
  533.  
  534. @(defun string (x)
  535. @
  536.     @(return `coerce_to_string(x)`)
  537. @)
  538.  
  539. siLstring_concatenate()
  540. {
  541.     int narg, i, l, m;
  542.     object *v;
  543.  
  544.     narg = vs_top - vs_base;
  545.     for (i = 0, l = 0;  i < narg;  i++) {
  546.         vs_base[i] = coerce_to_string(vs_base[i]);
  547.         l += vs_base[i]->st.st_fillp;
  548.     }
  549.     v = vs_top;
  550.     vs_push(alloc_simple_string(l));
  551.     (*v)->st.st_self = alloc_relblock(l);
  552.     for (i = 0, l = 0;  i < narg;  i++)
  553.         for (m = 0;  m < vs_base[i]->st.st_fillp;  m++)
  554.             (*v)->st.st_self[l++]
  555.             = vs_base[i]->st.st_self[m];
  556.     vs_base[0] = *v;
  557.     vs_top = vs_base + 1;
  558. }
  559.  
  560. init_string_function()
  561. {
  562.     Kstart1 = make_keyword("START1");
  563.     Kend1 = make_keyword("END1");
  564.     Kstart2 = make_keyword("START2");
  565.     Kend2 = make_keyword("END2");
  566.     Kinitial_element = make_keyword("INITIAL-ELEMENT");
  567.     Kstart = make_keyword("START");
  568.     Kend = make_keyword("END");
  569.  
  570.     make_function("CHAR", Lchar);
  571.     make_si_function("CHAR-SET", siLchar_set);
  572.     make_function("SCHAR", Lchar);
  573.     make_si_function("SCHAR-SET", siLchar_set);
  574.     make_function("STRING=", Lstring_eq);
  575.     make_function("STRING-EQUAL", Lstring_equal);
  576.     make_function("STRING<", Lstring_l);
  577.     make_function("STRING>", Lstring_g);
  578.     make_function("STRING<=", Lstring_le);
  579.     make_function("STRING>=", Lstring_ge);
  580.     make_function("STRING/=", Lstring_neq);
  581.     make_function("STRING-LESSP", Lstring_lessp);
  582.     make_function("STRING-GREATERP", Lstring_greaterp);
  583.     make_function("STRING-NOT-LESSP", Lstring_not_lessp);
  584.     make_function("STRING-NOT-GREATERP", Lstring_not_greaterp);
  585.     make_function("STRING-NOT-EQUAL", Lstring_not_equal);
  586.     make_function("MAKE-STRING", Lmake_string);
  587.     make_function("STRING-TRIM", Lstring_trim);
  588.     make_function("STRING-LEFT-TRIM", Lstring_left_trim);
  589.     make_function("STRING-RIGHT-TRIM", Lstring_right_trim);
  590.     make_function("STRING-UPCASE", Lstring_upcase);
  591.     make_function("STRING-DOWNCASE", Lstring_downcase);
  592.     make_function("STRING-CAPITALIZE", Lstring_capitalize);
  593.     make_function("NSTRING-UPCASE", Lnstring_upcase);
  594.     make_function("NSTRING-DOWNCASE", Lnstring_downcase);
  595.     make_function("NSTRING-CAPITALIZE", Lnstring_capitalize);
  596.     make_function("STRING", Lstring);
  597.  
  598.     make_si_function("STRING-CONCATENATE",
  599.              siLstring_concatenate);
  600. }
  601.